Pascal Super Library/Pascal Super Library (CW International)(1997).bin/PARSER/KPARS_00/FPARSER.PAS

Pascal/Delphi Source File | 1993-09-02 | 39KB | 1,307 lines

{$D+}
{$F+}
{$L+}
UNIT Fparser;
{+H
---------------------------------------------------------------------------
  Version     - 0.00

  File        - FPARSER.PAS

  Copyright   - None. Public Domain.

  Author      - Keith S. Brown (except where otherwise noted)
                Surface mail:              Email:([e-mail])
                  K.Brown
                  Code:NASA/JSC/ES64
                  Houston, TX 77058 (USA)  Voice:713-483-8952

  Purpose     - 1. Translate an infix expression to tokenized RPN.
                2. Execute a tokenized RPN expression.

  Language    - Borland International's Turbo Pascal V:4.x+ for MS-DOS

  Remarks     - Handles standard Pascal computational assignment expressions.
                With some differences, ie.:

              ■ as per Ada, numeric values may contain embedded underscores.

              ■ only the first 63 characters of an identifier are significant

              ■ the semi-colon terminating an expression is optional.

              ■ the extended unary functions "ArcCos", "ArcSin", "Log"
                (base 10), "Sign", "Step", "Tan" are available as well as
                the standard Pascal unary functions "Abs", "ArcTan", "Cos",
                "Exp", "Ln", "Round", "Sin", "Sqr", "Sqrt", "Trunc".

              ■ the extended binary operators "^" (as in x^3, cube of x) are
                available as well as the standard Pascal binary operators
                of "+", "-", "*", "/", "DIV", and "MOD".

              ■ the extended trinary functions:
                "Gate(x,cntr,wide:REAL):REAL;"     (rectangular pulse),
                "Gaus(x,cntr,variance:REAL):REAL;" (Gaussian pulse),
                "Sinc(x,cntr,wide:REAL):REAL;"     (Sin(πƒx)/(πƒx)) and
                "Tri(x,cntr,wide:REAL):REAL;"      (Triangular pulse)
                are available.

              ■ The constants "Pi" (3.1415...) and "e" (2.7182...) are predefined.


              ■ the assignment of the result to a variable is optional.
                However, if no assignment is made, use EvaluatePostfix
                instead of ExecutePostfix.

  Requires    - Turbo Power Professional's TPSTRING unit --> basic string handling
                (requires proc/functs: DisposeString, LeftPad, Str2Real, StringFromHeap, StringToHeap)
                KSTRING.PAS --> extended string handling
                KMATH.PAS   --> math functions

   Example:
      BEGIN
        InitSymbolTable;

        DefineParameter('y',30.0);
        DefineParameter('x',0);

        IF TranslateToPostfix('x := Sin(y*Pi/180);') THEN
          IF ExecutePostFix THEN
            WriteLn('Result = ',ViewParameter('x'));
      END;

   Example:
      VAR
        x : REAL;
      BEGIN
        InitSymbolTable;

        DefineParameter('y',30.0);

        IF TranslateToPostfix('Sin(y*Pi/180);') THEN
          IF EvaluatePostFix(x) THEN
            WriteLn('Result = ',x);
      END;

  Reference   - Data Structures & Program Design, Robert L. Kruse
                (Chptr 8: The Polish Notation) pp311-355

  Revised     - 1991.0618 (KSB) Converted from GF and made a unit.
              - 1993.0901 (KSB) Updated documentation.
---------------------------------------------------------------------------}
INTERFACE

{}PROCEDURE InitSymbolTable;
    {Must be called first
    }
{}PROCEDURE DefineParameter(s:STRING; v:REAL);
    {call as many times as needed to define & initialize variables
    }
{}FUNCTION  ViewParameter(s:STRING):REAL;
    {call after EvaluatePostfix to examine results
    }
{}FUNCTION  TranslateToPostfix(s:STRING):BOOLEAN;
    {"Compiles" expression for use by EvaluatePostfix
    }
{}FUNCTION  ExecutePostfix:BOOLEAN;
    {"Executes" expression "compiled" by TranslateToPostfix
    }
{}FUNCTION  EvaluatePostfix(VAR x:REAL):BOOLEAN;
    {"Executes" expression "compiled" by TranslateToPostfix when
      the result is not assigned to a variable.
    }

     {====================================================================}

IMPLEMENTATION
USES
  TPstring,
  Kmath,    Kstring;

CONST
  LastSymbol  = 4;

  FirstUnary  = LastSymbol+1;  { index of first unary operator }
  LastUnary   = LastSymbol+17; { index of last  unary operator }

  FirstBinary = LastUnary+1;   { index of first binary operator }
  LastBinary  = LastUnary+7;   { index of last  binary operator }

  FirstTrinary= LastBinary+1;  { index of first trinary operator }
  LastTrinary = LastBinary+4;  { index of last  trinary operator }

  AssgnOperand= LastTrinary+1;

  FirstOperand= AssgnOperand+1;{ index of first operands }
  LastOperand = AssgnOperand+2;{ index of last predefined operand; others introduced by the user with the expression }

  MaxExpression    = 255;      { maximum number of tokens in an expression }
  MaxPriority = 7;             { largest priority of any operator }
  MaxToken    = 100;
  MaxStack    = 100;           { max stack size }

  NameLength  = 63;            { number of characters in an identifier }
  HashSize    = 101;

TYPE
  exprindex   = 0..MaxExpression;
  indexstring = 0..255;
  NAME   = STRING[NameLength];
  priorrange  = 1..MaxPriority;
  token  = 0..MaxToken;
  value  = REAL;               { for simplicity, keep all the variables real }

  expPtr = ^expression;
  expression  =
  RECORD
    L : exprIndex;
    e : ARRAY[1..MaxExpression]OF token;
  END {RECORD};

  tokenkind   = (
  operand,
  unaryop,
  binaryop,
  trinaryop,
  assignOp,
  endexpression,
  leftparen,
  rightparen,
  comma);

  deftoken    =
  RECORD
    nm : POINTER;
    CASE k : tokenkind OF
      operand    : (Val : REAL);
      unaryop,
      binaryop,
      trinaryop,
      assignop   : (pri : priorrange);
      endexpression,
      leftparen,
      rightparen,
      comma      : ()
  END {RECORD};



VAR
  infix  : expression;     { tokenized infix expression }
  postfix: expression;     { tokenized RPN expression   }

CONST
  e_UnknownId = 1;
  e_DataTooBig= 2;
  e_IdExpected= 3;
  e_BadConstPos    = 4;
  e_BadRealConst   = 5;
  e_UnknSymbol= 6;
  e_CloseParen= 7;
  e_BadBiOpPos= 8;
  e_BiOpExpected   = 9;
  e_UnequalParen   = 10;
  e_BadExpression  = 11;
  e_CodeOverflow   = 12;
  e_BadGetVal = 13;
  e_BadUniOpCode   = 14;
  e_BadBiOpCode    = 15;
  e_ZeroDivide= 16;
  e_BadFloatOp= 17;
  e_BadTriOpcode   = 18;


{}FUNCTION ErrMsg(n:WORD):STRING;
{---------------------------------------------------------------------------
  Purpose     - Return a descriptive error message for an error number.
---------------------------------------------------------------------------}
  CONST   {....^....1....^....2....^....3....^....4....^....5....^}
    errs : ARRAY [1..18] OF STRING[37] = (
{*}'Unknown identifier',
{*}'Data segment too large',
{*}'Identifier expected',
{*}'Constant in illegal position',
{*}'Error in Real Constant',
{*}'Unrecognized symbol in expression',
{*}'Illegal place for closing parenthesis',
{*}'Binary operator in illegal position',
{*}'Binary operator or ) expected',
{*}'Unmatched parentheses',
{*}'Error in expression',

{*}'Code overflow',
{*}'Attempt to get value for non-operand',
{*}'Unary operator code out of range',
{*}'Binary operator code out of range',
{*}'Division by zero',
{*}'Invalid floating point operation',
{*}'Trinary operator code out of range'
);
  BEGIN
    ErrMsg := errs[n];
{}END {ErrMsg};




{}FUNCTION NumPars(s:STRING):REAL;
{---------------------------------------------------------------------------
  Purpose     - Convert a string to a real and default to zero if unparsable.
---------------------------------------------------------------------------}
  VAR
    r    : REAL;
  BEGIN
    IF NOT Str2Real(ReplaceAll(s,'_',''),r) THEN
      r := 0;
    NumPars := r;
{}END {NumPars};




                    {--------------------------------------}

TYPE
  StackObj    = OBJECT
{---------------------------------------------------------------------------
  Purpose     - Stack manager for "compiling" and "executing". Tokens,
                (symbol table indexes) are pushed/popped/looked at as reqd.
---------------------------------------------------------------------------}
    size    : 0..MaxStack;      { number of operators on stack }
    stack   : ARRAY[1..MaxStack] OF token;

    CONSTRUCTOR Init;
    PROCEDURE   Push(t:Token);
    FUNCTION    Pop      :Token;
    FUNCTION    LookAt(i:WORD):Token;
    PROCEDURE   Error(n:WORD);
  END {OBJECT};




{}CONSTRUCTOR StackObj.Init;
  BEGIN
    FillChar(stack,SizeOf(stack),0);
    size := 0;
{}END {Init};




{}PROCEDURE StackObj.Push(t : token);
  BEGIN
    IF size >= MaxStack THEN
      Error(1)
    ELSE BEGIN
      Inc(size);
      stack[size] := t;
    END {IF};
{}END {Push};




{}FUNCTION StackObj.Pop:Token;
  BEGIN
    IF size <= 0 THEN
      Error(2)
    ELSE BEGIN
      Pop := stack[size];
      stack[size] := 0;
      Dec(size);
    END {IF};
{}END {Pop};




{}FUNCTION StackObj.LookAt(i:WORD):Token;
  BEGIN
    LookAt := stack[i];
{}END {LookAt};




{}PROCEDURE StackObj.Error(n:WORD);
  CONST
    errs : ARRAY[1..2]OF STRING[9]= ('overflow','underflow');
  BEGIN
    WriteLn('Stack Error: ',errs[n],'.');
    Halt;
{}END {Error};




                    {--------------------------------------}

TYPE
  SymbolTableObj   = OBJECT
{---------------------------------------------------------------------------
  Purpose     - Manages the Symbol table by adding identifiers/values,
                changing values for an id (or token), adding/deleting
                temporary variables, and returning type information for an
                existing symbol.
---------------------------------------------------------------------------}
    size    : token;                        { number of distinct tokens }
    entrys  : ARRAY[token]OF defToken;      { information on all tokens }

    CONSTRUCTOR Init;
    PROCEDURE   AddOperand(n:NAME; v:REAL);
    FUNCTION    GetValue(t:token):REAL;
    PROCEDURE   SetValue(t:token; v:REAL);
    FUNCTION    AddTemp(v:REAL):token;
    PROCEDURE   RemoveTemps;
    PROCEDURE   Error(n:WORD; INDEX:INTEGER; p:POINTER);
    FUNCTION    Kind(t:token):tokenKind;
    FUNCTION    KindType(t:token):STRING;
  END {OBJECT};




{}CONSTRUCTOR SymbolTableObj.Init;
  BEGIN
    size := 0;
    FillChar(entrys,SizeOf(entrys),0);
{}END {Init};




{}FUNCTION SymbolTableObj.Kind(t : token) : tokenkind;
  BEGIN
    Kind := entrys[t].k;
{}END {Kind};




{}FUNCTION SymbolTableObj.KindType(t:token):STRING;
  BEGIN
    CASE entrys[t].k OF
      operand      : KindType := 'Operand  ';
      unaryop      : KindType := 'U Op code';
      binaryop     : KindType := 'B Op code';
      trinaryop    : KindType := 'T Op code';
      endexpression: KindType := '-->END<--';
      leftparen    : KindType := 'L paren  ';
      rightparen   : KindType := 'R paren  ';
      comma        : KindType := 'comma    ';
    END {CASE};
{}END {KindType};




{}PROCEDURE SymbolTableObj.Error(n:WORD; INDEX:INTEGER; p:POINTER);
{---------------------------------------------------------------------------
  Remark      - N is the error number.
                P is either a pointer to an expression or to a string.
            INDEX if negative, indicates that P points to a string. In such
                  case ABS(INDEX) is the position in the string where the
                  error occured.
                  If positive, indicates that P points to an expression. In
                  such a case the INDEX'th token is the one causing (or near
                  to) the error.
---------------------------------------------------------------------------}
  TYPE
    StrPtr    = ^STRING;
  VAR
    s    : StrPtr ABSOLUTE p;
    e    : ExpPtr ABSOLUTE p;
  BEGIN
    WriteLn('Symbol Table Error: (',n,') ',ErrMsg(n));

    IF p <> NIL THEN
      IF INDEX < 0 THEN BEGIN
        INDEX := Abs(INDEX);
        WriteLn(s^);
        WriteLn(LeftPad('^',INDEX));
      END ELSE BEGIN
      WriteLn('Error near ',StringFromHeap(entrys[e^.e[INDEX]].nm));
    END {BEGIN};

    Halt;
{}END {Error};




{}PROCEDURE SymbolTableObj.AddOperand(n:NAME; v:REAL);
  BEGIN
    Inc(size);
    WITH entrys[size] DO BEGIN
      nm := StringToHeap(n);
      k  := Operand;
      Val:= v;
    END {WITH};
{}END {AddOperand};




{}FUNCTION SymbolTableObj.GetValue(t : token) : REAL;
  BEGIN
    IF Kind(t) <> operand THEN
      Error(e_BadGetVal,t,NIL)
    ELSE
      GetValue := entrys[t].Val;
{}END {GetValue};




{}PROCEDURE SymbolTableObj.SetValue(t:token; v:REAL);
  BEGIN
    WITH entrys[t] DO BEGIN
      IF k <> operand THEN
        Error(e_IdExpected,t,NIL)
      ELSE
        Val := v;
    END {WITH};
{}END {SetValue};




{}FUNCTION  SymbolTableObj.AddTemp(v:REAL):token;
{---------------------------------------------------------------------------
  Remark      - All temporary variables are of the form "$T$nnn" where "nnn"
                is a unique integer value.
---------------------------------------------------------------------------}
  BEGIN
    Inc(size);
    WITH entrys[size] DO BEGIN
      nm := StringToHeap('$T$'+Long2Str(size));
      k  := Operand;
      Val:= v;
    END {WITH};
    AddTemp := size;
{}END {AddTemp};




{}PROCEDURE SymbolTableObj.RemoveTemps;
{---------------------------------------------------------------------------
  Remark      - Removes all temporary variables created during the execution
                of an RPN expression.
---------------------------------------------------------------------------}
  BEGIN
    WHILE size > FirstOperand DO
      IF Copy(StringFromHeap(entrys[size].nm),1,3) = '$T$' THEN
        WITH entrys[size] DO BEGIN
          DisposeString(nm);
          Val := 0;
          Dec(size);
        END {WITH} ELSE
      Exit;
{}END {RemoveTemps};




VAR
  dictionary  : SymbolTableObj;

                    {--------------------------------------}

TYPE
  HashObj= OBJECT
{---------------------------------------------------------------------------
  Purpose     - Manages a hash table.
  Remark      - The hash table is used to speed up the symbol table access,
                so that the entire table need not be searched to check for
                a symbol's existance.
---------------------------------------------------------------------------}
    h  : ARRAY[0..HashSize]OF Token;

    CONSTRUCTOR Init;
    FUNCTION    Hash(x:NAME):WORD;
    FUNCTION    LookFor(x:NAME):Token;
    PROCEDURE   AssignToken(x:NAME;t:Token);
    PROCEDURE   Error;
  END {OBJECT};




{}PROCEDURE HashObj.Error;
  BEGIN
    WriteLn('Hash Error: Attempt to hash zero length string.');
    Halt;
{}END {Error};




{}PROCEDURE HashObj.AssignToken(x:NAME;t:Token);
  BEGIN
    h[Hash(x)] := t;
{}END {AssignToken};




{}FUNCTION HashObj.LookFor(x:NAME):Token;
  BEGIN
    LookFor := h[Hash(x)];      { look for token in hash table }
{}END {LookFor};




{}FUNCTION HashObj.Hash(x : NAME) : WORD;
  VAR
    a    : INTEGER;
    ch   : CHAR;
    found: BOOLEAN;
  BEGIN
    IF Length(x) <= 0 THEN
      Error
    ELSE BEGIN
      ch := x[1];
      a  := Abs(Ord(ch)) MOD hashsize;
      REPEAT
        IF h[a] = 0 THEN
          found := TRUE
        ELSE
        IF StringFromHeap(dictionary.entrys[h[a]].nm) = x THEN
          found := TRUE
        ELSE BEGIN
          IF Length(x) > 1 THEN BEGIN
            ch := x[2];
            a  := a + Abs(Ord(ch))
          END ELSE
            a  := a + 29;

          IF a > hashsize THEN
            a := a MOD hashsize;

          found := FALSE;
        END {IF};
      UNTIL found;
      Hash := a;
    END {IF};
{}END {Hash};




{}CONSTRUCTOR HashObj.Init;
  VAR
    t    : token;
  BEGIN
    FillChar(h,SizeOf(h),0);    { Initialize hash table }

    FOR t := 1 TO lastoperand DO
      h[Hash(StringFromHeap(dictionary.entrys[t].nm))] := t;
{}END {Init};




VAR
  h : HashObj;             {global because is used by DefineParameter,
                                 ViewParameter and TranslateToPostfix}

                    {--------------------------------------}


{}PROCEDURE InitSymbolTable;
{+H
---------------------------------------------------------------------------
  Purpose     - Initialize the defaults in the symbol table.

  Declaration - procedure InitSymbolTable.

  Remarks     - Must be called first to initialize symbols and operators.
---------------------------------------------------------------------------}
  BEGIN
    dictionary.Init;

    WITH dictionary DO BEGIN
      WITH entrys[ 1] DO BEGIN nm := StringToHeap(';');     k := endexpression;      END {WITH};
      WITH entrys[ 2] DO BEGIN nm := StringToHeap('(');     k := leftparen;          END {WITH};
      WITH entrys[ 3] DO BEGIN nm := StringToHeap(')');     k := rightparen;         END {WITH};
      WITH entrys[ 4] DO BEGIN nm := StringToHeap(',');     k := comma;              END {WITH};

  {01}WITH entrys[ 5] DO BEGIN nm := StringToHeap('~');     k := unaryop;  pri := 6; END {WITH};
  {02}WITH entrys[ 6] DO BEGIN nm := StringToHeap('ABS');   k := unaryop;  pri := 7; END {WITH};
  {03}WITH entrys[ 7] DO BEGIN nm := StringToHeap('SQR');   k := unaryop;  pri := 7; END {WITH};
  {04}WITH entrys[ 8] DO BEGIN nm := StringToHeap('SQRT');  k := unaryop;  pri := 7; END {WITH};
  {05}WITH entrys[ 9] DO BEGIN nm := StringToHeap('EXP');   k := unaryop;  pri := 7; END {WITH};
  {06}WITH entrys[10] DO BEGIN nm := StringToHeap('LN');    k := unaryop;  pri := 7; END {WITH};
  {07}WITH entrys[11] DO BEGIN nm := StringToHeap('LOG');   k := unaryop;  pri := 7; END {WITH};
  {08}WITH entrys[12] DO BEGIN nm := StringToHeap('SIN');   k := unaryop;  pri := 7; END {WITH};
  {09}WITH entrys[13] DO BEGIN nm := StringToHeap('COS');   k := unaryop;  pri := 7; END {WITH};
  {10}WITH entrys[14] DO BEGIN nm := StringToHeap('TAN');   k := unaryop;  pri := 7; END {WITH};
  {11}WITH entrys[15] DO BEGIN nm := StringToHeap('ARCSIN');k := unaryop;  pri := 7; END {WITH};
  {12}WITH entrys[16] DO BEGIN nm := StringToHeap('ARCCOS');k := unaryop;  pri := 7; END {WITH};
  {13}WITH entrys[17] DO BEGIN nm := StringToHeap('ARCTAN');k := unaryop;  pri := 7; END {WITH};
  {14}WITH entrys[18] DO BEGIN nm := StringToHeap('ROUND'); k := unaryop;  pri := 7; END {WITH};
  {15}WITH entrys[19] DO BEGIN nm := StringToHeap('TRUNC'); k := unaryop;  pri := 7; END {WITH};
  {16}WITH entrys[20] DO BEGIN nm := StringToHeap('SIGN');  k := unaryop;  pri := 7; END {WITH};
  {17}WITH entrys[21] DO BEGIN nm := StringToHeap('STEP');  k := unaryop;  pri := 7; END {WITH};

  {01}WITH entrys[22] DO BEGIN nm := StringToHeap('+');     k := binaryop; pri := 4; END {WITH};
  {02}WITH entrys[23] DO BEGIN nm := StringToHeap('-');     k := binaryop; pri := 4; END {WITH};
  {03}WITH entrys[24] DO BEGIN nm := StringToHeap('*');     k := binaryop; pri := 5; END {WITH};
  {04}WITH entrys[25] DO BEGIN nm := StringToHeap('/');     k := binaryop; pri := 5; END {WITH};
  {05}WITH entrys[26] DO BEGIN nm := StringToHeap('DIV');   k := binaryop; pri := 5; END {WITH};
  {06}WITH entrys[27] DO BEGIN nm := StringToHeap('MOD');   k := binaryop; pri := 5; END {WITH};
  {07}WITH entrys[28] DO BEGIN nm := StringToHeap('^');     k := binaryop; pri := 7; END {WITH};

  {01}WITH entrys[29] DO BEGIN nm := StringToHeap('GATE');  k := trinaryop;pri := 7; END {WITH};
  {02}WITH entrys[30] DO BEGIN nm := StringToHeap('GAUS');  k := trinaryop;pri := 7; END {WITH};
  {03}WITH entrys[31] DO BEGIN nm := StringToHeap('SINC');  k := trinaryop;pri := 7; END {WITH};
  {04}WITH entrys[32] DO BEGIN nm := StringToHeap('TRI');   k := trinaryop;pri := 7; END {WITH};

  {01}WITH entrys[33] DO BEGIN nm := StringToHeap(':=');    k := assignop; pri := 1; END {WITH};

  {01}WITH entrys[34] DO BEGIN nm := StringToHeap('PI');    k := operand;  Val := Pi;END {WITH};
  {02}WITH entrys[35] DO BEGIN nm := StringToHeap('E');     k := operand;  Val := Exp(1); END {WITH};
    END {WITH};

    dictionary.size := lastoperand;
    h.Init;
{}END {InitSymbolTable};




{}FUNCTION TranslateToPostfix(s:STRING):BOOLEAN;
{+H
---------------------------------------------------------------------------
  Purpose     - Translate an infix expression to RPN.

  Declaration - function TranslateToPostfix(s:STRING):BOOLEAN;

  Remarks     - The infix expression is first tokenized. However, all
                identifiers must be previously declared.
---------------------------------------------------------------------------}
  CONST
    maxstring = 255;            { maximum length of input string}
  TYPE
    indexname = 0..NameLength;  { used to loop through a name }
    indexstring    = 0..maxstring;  { used to traverse input string }
  VAR
    position  : indexstring;    { moves through input string }
    stx  : StackObj;


{}{}FUNCTION  ReadExpression(s:STRING):BOOLEAN;
    CONST
      IsTri   : BOOLEAN = FALSE;
      commas  : WORD    = 0;
      digit   : SET OF CHAR  = ['0'..'9'];
    VAR
      parenCnt: INTEGER;        { checks for balanced parentheses }
      term    : WORD;


{}{}{}FUNCTION Leading : BOOLEAN;
      VAR
        k: tokenkind;
      BEGIN
        IF infix.L = 0 THEN
          Leading := TRUE       { This is start of expression }
        ELSE BEGIN
          k := dictionary.Kind(infix.e[infix.L]); { Look at preceding token.}
          Leading := (k = leftparen) OR
                      (k = unaryop)   OR
                      (k = binaryop)  OR
                      (k = trinaryop) OR
                      (k = assignop)  OR
                      (k = comma);
        END {IF};
{}{}{}END {Leading};


{}{}{}PROCEDURE PutToken(t : token);
      BEGIN
        Inc(infix.L);
        infix.e[infix.L] := t;
{}{}{}END {PutToken};


{}{}{}PROCEDURE Find_word;
{---------------------------------------------------------------------------
  Purpose     - Extract an alpha-numeric symbol from the input text.
---------------------------------------------------------------------------}
      CONST
        alphabet   : SET OF CHAR  = ['A'..'Z','_'];
      VAR
        a_word: NAME;
        t: token;
        i: indexname;
        newPos: indexstring;
        ch    : CHAR;
      BEGIN
        newPos := Succ(position);     { find end of a_word }
        WHILE s[newPos] IN (alphabet + digit) DO
          Inc(newPos);

        IF newPos - position <= NameLength THEN
          a_word := Copy(s,position,newPos - position)
        ELSE                          { truncate to NameLength characters }
          a_word := Copy(s,position,NameLength);

        t := h.LookFor(a_word);       { look for token in hash table }
        IF t <> 0 THEN                { token is already defined }
          IF Leading THEN
            IF dictionary.Kind(t) = binaryop THEN
              dictionary.Error(e_BadBiOpPos,-newPos,@s)
            ELSE
              PutToken(t)             { Other kinds are legal in leading position }
          ELSE                        { not in a leading position }
          IF dictionary.Kind(t) <> binaryop THEN
            dictionary.Error(e_BiOpExpected,-newPos,@s)
          ELSE
            PutToken(t)
        ELSE
          dictionary.Error(e_UnknownId,-newPos,@s); { Unknown or undefined}

        position := newPos;
{}{}{}END {Find_word};


{}{}{}PROCEDURE FindNumber;
      VAR
        numbername,
        x: STRING[80];
        decpoint,               { position of decimal point, if any }
        scinot,                 { position of start of scientific notation}
        newPos: indexstring;
        fraction,
        r: REAL;                { value of number, converted to binary }
        i: INTEGER;
      BEGIN
        IF NOT Leading THEN
          dictionary.Error(e_BadConstPos,infix.L,@infix)
        ELSE
        IF dictionary.size >= maxtoken THEN
          dictionary.Error(e_DataTooBig,infix.L,@infix)
        ELSE BEGIN
          newPos := position;   { Legal case; name a new token }

          WHILE s[newPos] IN digit+['_'] DO
            Inc(newPos);

          x := Copy(s,position,newPos - position);

          IF s[newPos] = '.' THEN BEGIN
            decpoint := newPos; { fractional part }
            REPEAT
              Inc(newPos)
            UNTIL  NOT (s[newPos] IN digit+['_']);
            x := x + Copy(s,decpoint,newPos - decpoint);
          END {IF};

          IF s[newPos] IN ['E','e'] THEN BEGIN
            scinot := newPos;
            Inc(newPos);
            IF  NOT (s[newPos] IN ['+','-'] + digit) THEN
              dictionary.Error(e_BadRealConst,newPos,@s);
            REPEAT
              Inc(newPos);
            UNTIL  NOT (s[newPos] IN digit+['_']);
            x := x + Copy(s,scinot,newPos - scinot);
          END {IF};

          r := NumPars(x);
          Inc(dictionary.size);
          WITH dictionary.entrys[dictionary.size] DO BEGIN
            Str(r,numberName);  { normalized string rep }
            nm := StringToHeap(numberName);
            k  := operand;
            Val:= r;
          END {WITH};

          PutToken(dictionary.size);
          position := newPos;
        END {IF};
{}{}{}END {FindNumber};


{}{}{}PROCEDURE FindSymbol;
{}{}{}{}FUNCTION Next(s:STRING; n:indexString):CHAR;
        VAR
          L   : BYTE ABSOLUTE s;
        BEGIN
          IF n > L THEN
            Next := ' '
          ELSE
            Next := s[n+1];
{}{}{}{}END {Next};


{}{}{}{}FUNCTION SySet(s:STRING; VAR n:indexString; i:BYTE):NAME;
        BEGIN
          SySet := s;
          n := n + i;
{}{}{}{}END {SySet};


      CONST
        symbols    : SET OF CHAR  = ['(',')','*','+',',','-','/',':','<','=','>'];
      VAR
        x: NAME;
        L: BYTE ABSOLUTE s;
        t: token;
        newPos: indexString;
      BEGIN
        newPos := position;
        x      := '';

        CASE s[newPos] OF
          ':' :
          CASE Next(s,newPos) OF
            '=' : x := SySet(':=',newPos,+1);
            ELSE
              x := SySet(':', newPos, 0);
          END {CASE};

          '<' :
          CASE Next(s,newPos) OF
            '>' : x := SySet('<>',newPos,+1);
            '=' : x := SySet('<=',newPos,+1);
            ELSE
              x := SySet('<', newPos, 0);
          END {CASE};

          '>' :
          CASE Next(s,newPos) OF
            '=' : x := SySet('>=',newPos,+1);
            ELSE
              x := SySet('>', newPos, 0);
          END {CASE};

          ELSE
            x := s[newPos];
        END {CASE};

        t := h.LookFor(x);

        IF t = 0 THEN
          dictionary.Error(e_UnknSymbol,-position,@s)
        ELSE
        IF Leading THEN
          IF dictionary.Kind(t) = rightparen THEN
            dictionary.Error(e_CloseParen,-position,@s)
          ELSE
          IF dictionary.Kind(t) = binaryop THEN BEGIN
            CASE x [ 1 ] OF     { A binary operator is illegal here; it must be a unary operator}
              '+' : ;
              '-' :
              BEGIN
                x := '~';       { unary negation }
                t := h.LookFor(x);
                PutToken(t);
              END {BEGIN};

              ELSE
                dictionary.Error(e_BadBiOpPos,-position,@s);
            END {CASE};
          END ELSE
            PutToken(t)         { other kinds are legal }
      ELSE
      IF (dictionary.Kind(t) = rightparen) OR   { not in leading position }
            (dictionary.Kind(t) = comma)      OR
            (dictionary.Kind(t) = binaryop)   OR
            (dictionary.Kind(t) = assignOp) THEN
        PutToken(t)
      ELSE
        dictionary.Error(e_BiOpExpected,-position,@s);

        IF dictionary.Kind(t) = leftparen THEN
          Inc(parenCnt)
        ELSE
        IF dictionary.Kind(t) = rightparen THEN BEGIN
          Dec(parenCnt);
          IF parenCnt < 0 THEN
            dictionary.Error(e_UnequalParen,-position,@s);
        END {IF};

        position := newPos;
        Inc(position);
{}{}{}END {FindSymbol};


    BEGIN  {--- ReadExpression ---}
      s          := StUpCase(s) + ' '; { blank is a sentinel for searches }
      infix.L    := 0;
      parenCnt   := 0;
      position   := 1;

      WHILE (position <= Length(s)) AND (s[position] <> ';') DO
        CASE s[position] OF
          ' '      : Inc(position); { skip all blanks between tokens }
          'A'..'Z' : Find_word;
          '0'..'9',
          '.'      : FindNumber;
          ELSE
            FindSymbol;
        END {CASE} ;

      IF parenCnt <> 0 THEN
        dictionary.Error(e_UnequalParen,-position,@s);

      IF Leading THEN
        dictionary.Error(e_BadExpression,infix.L,NIL);

      PutToken(1);              { Put endexpression into the output.}
{}{}END {ReadExpression};


{}{}PROCEDURE Translate;
    VAR
      t,                        { token currently being processed }
      x  : token;               { operator popped from stack }
      endright: BOOLEAN;

{}{}{}PROCEDURE GetToken(VAR t : token);
      BEGIN
        t := infix.e[infix.L];
        Inc(infix.L);
        IF infix.L > MaxExpression THEN
          dictionary.Error(e_CodeOverflow,0,NIL);
{}{}{}END {GetToken};


{}{}{}PROCEDURE PutToken(t : token);
      BEGIN
        Inc(postfix.L);
        postfix.e[postfix.L] := t;
{}{}{}END {PutToken};


{}{}{}FUNCTION Priority(t : token) : INTEGER;
      BEGIN
        Priority := dictionary.entrys[t].pri;
{}{}{}END {Priority};


    BEGIN
      stx.Init;
      infix.L := 1;
      postfix.L := 0;
      REPEAT
        GetToken(t);
        CASE dictionary.Kind ( t ) OF
          operand    : PutToken(t);
          leftparen  : stx.Push(t);
          rightparen :
          BEGIN
            t := stx.Pop;
            WHILE dictionary.Kind(t) <> leftparen DO BEGIN
              PutToken(t);
              t := stx.Pop;     { discard left parenthesis }
            END {WHILE};
          END {BEGIN};
          unaryop,
          binaryop,
          trinaryop,
          assignop   :
          BEGIN
            REPEAT
              IF (stx.size = 0) OR
                 (dictionary.Kind(stx.LookAt(stx.size)) = leftparen) OR
                 (Priority(stx.LookAt(stx.size)) < Priority(t)) THEN
                endright := TRUE
              ELSE BEGIN
                endright := FALSE;
                x := stx.Pop;
                PutToken(x);
              END {IF};
            UNTIL endright;
            stx.Push(t);
          END {BEGIN};

          endexpression:
          WHILE stx.size > 0 DO
            PutToken(stx.Pop);  {empty the stack}

        END {CASE};

      UNTIL dictionary.Kind(t) = endexpression;
      PutToken(t);
{}{}END {Translate};


  BEGIN
    FillChar(infix,  SizeOf(expression),0);
    FillChar(postfix,SizeOf(expression),0);

    IF ReadExpression(s) THEN BEGIN
      Translate;
      TranslateToPostfix := TRUE;
    END ELSE
      TranslateToPostfix := FALSE;
{}END {TranslateToPostfix};




{}PROCEDURE DefineParameter(s:STRING; v:REAL);
{+H
---------------------------------------------------------------------------
  Purpose     - If S is not defined add it with its value V to the symbol
                table. If it is found, change its value to V.

  Declaration - procedure DefineParameter(s:STRING; v:REAL);
---------------------------------------------------------------------------}
  VAR
    t    : Token;
  BEGIN
    s := StUpCase(Trim(s));
    t := h.LookFor(s);

    IF t <> 0 THEN BEGIN        { token is one already defined }
      IF t < FirstOperand THEN
        dictionary.Error(e_IdExpected,infix.L,NIL)
      ELSE
        dictionary.entrys[t].Val := v;
    END ELSE                    { new name for token; must set up definition }
    IF dictionary.size >= maxtoken THEN
      dictionary.Error(e_DataTooBig,infix.L,NIL)
    ELSE BEGIN
      Inc(dictionary.size);
      h.AssignToken(s,dictionary.size);
      WITH dictionary.entrys[dictionary.size] DO BEGIN
        nm := StringToHeap(s);
        k  := operand;
        Val:= v;
      END {WITH};
    END {IF};
{}END {DefineParameter};




{}FUNCTION  ViewParameter(s:STRING):REAL;
{+H
---------------------------------------------------------------------------
  Purpose     - If S is not defined display an error message.  If it is
                found, return its value.

  Declaration - function ViewParameter(s:STRING):REAL;
---------------------------------------------------------------------------}
  VAR
    t    : Token;
  BEGIN
    s := StUpCase(Trim(s));
    t := h.LookFor(s);

    IF t <> 0 THEN BEGIN        { token is one already defined }
      IF t < FirstOperand THEN
        dictionary.Error(e_IdExpected,infix.L,NIL)
      ELSE
        ViewParameter := dictionary.entrys[t].Val;
    END ELSE
      dictionary.Error(e_IdExpected,0,NIL);
{}END {ViewParameter};




VAR
  RPNresult   : REAL;


{}FUNCTION  ExecutePostfix:BOOLEAN;
{+H
---------------------------------------------------------------------------
  Purpose     - Interpret a RPN expression.

  Declaration - function ExecutePostfix:BOOLEAN;
---------------------------------------------------------------------------}
{}{}PROCEDURE GetToken(VAR t : token);
    BEGIN
      t := postfix.e[postfix.L];
      Inc(postfix.L);
      IF postfix.L > MaxExpression THEN
        dictionary.Error(e_CodeOverflow,postfix.L,@postfix);
{}{}END {GetToken};


{}{}FUNCTION DoUnary(t : token;  x : REAL) : REAL;
    BEGIN
      IF (t < firstunary) OR
          (t > lastunary) THEN
        dictionary.Error(e_BadUniOpcode,postfix.L,@postfix)
      ELSE
        CASE (t-LastSymbol) OF
          1 : DoUnary :=  - x;
          2 : DoUnary := Abs(x);
          3 : DoUnary := Sqr(x);

          4 :
          IF x < 0 THEN
            dictionary.Error(e_BadFloatOp,postfix.L,@postfix)
          ELSE
            DoUnary := Sqrt(x);

          5 :
          IF x > 87 THEN
            DoUnary := Exp(87)
          ELSE
          IF x <  - 87 THEN
            DoUnary := 0
          ELSE
            DoUnary := Exp(x);

          6 :
          IF x <= 0 THEN
            dictionary.Error(e_BadFloatOp,postfix.L,@postfix)
          ELSE
            DoUnary := Ln(x);

          7 :
          IF x <= 0 THEN
            dictionary.Error(e_BadFloatOp,postfix.L,@postfix)
          ELSE
            DoUnary := Ln(x)/Ln(10);

          8 : DoUnary := Sin(x);
          9 : DoUnary := Cos(x);
          10 : DoUnary := Tan(x);
          11 : DoUnary := ArcSin(x);
          12 : DoUnary := ArcCos(x);
          13 : DoUnary := ArcTan(x);
          14 : DoUnary := Round(x);
          15 : DoUnary := Trunc(x);
          16 : DoUnary := Sign(x);
          17 : DoUnary := Step(x);
        END {CASE};
{}{}END {DoUnary};


{}{}FUNCTION DoBinary(t : token;  y,x : REAL) : REAL;
    VAR
      err: BYTE;
    BEGIN
      IF (t < firstbinary) OR
          (t > lastbinary) THEN
        dictionary.Error(e_BadBiOpCode,postfix.L,@postfix)
      ELSE
        CASE (t-LastUnary) OF
          1 : DoBinary := x + y;
          2 : DoBinary := x - y;
          3 : DoBinary := x*y;

          4 :
          IF y = 0 THEN
            dictionary.Error(e_ZeroDivide,postfix.L,@postfix)
          ELSE
            DoBinary := x/y;

          5 :
          IF Round(y) = 0 THEN
            dictionary.Error(e_ZeroDivide,postfix.L,@postfix)
          ELSE
            DoBinary := Round(x) DIV Round(y);

          6 :
          IF Round(y) = 0 THEN
            dictionary.Error(e_ZeroDivide,postfix.L,@postfix)
          ELSE
            DoBinary := Round(x) MOD Round(y);

          7 :
          BEGIN
            DoBinary := Exponent(x,y,err);
            IF err <> 0 THEN
              dictionary.Error(e_BadFloatOp,postfix.L,@postfix);
          END {BEGIN};

          8 :
          BEGIN
            x := y;
            DoBinary := x;
          END {BEGIN};
        END {CASE};
{}{}END {DoBinary};


{}{}FUNCTION DoTrinary(t:token; z,y,x:REAL) :REAL;
    BEGIN
      IF (t < firsttrinary) OR
          (t > lasttrinary) THEN
        dictionary.Error(e_BadTriOpcode,postfix.L,@postfix)
      ELSE
        CASE (t-LastBinary) OF
          1 : DoTrinary := Gate(x,y,z);
          2 : DoTrinary := Gaussian(x,y,z);
          3 : DoTrinary := Sinc(x,y,z);
          4 : DoTrinary := Triangle(x,y,z);
        END {CASE};
{}{}END {DoTrinary};


  VAR
    stx  : StackObj;
    t    : token;
  BEGIN {--- ExecutePostFix ---}
    ExecutePostFix := FALSE;
    stx.Init;

    postfix.L := 1;
    REPEAT
      GetToken(t);
      CASE dictionary.Kind(t) OF
        operand   : stx.Push(t);

        unaryOp   : stx.Push(dictionary.AddTemp(DoUnary(t,dictionary.GetValue(stx.Pop))));

        binaryOp  : stx.Push(dictionary.AddTemp(DoBinary(t,dictionary.GetValue(stx.Pop),dictionary.GetValue(stx.Pop))));

        trinaryOp : stx.Push(dictionary.AddTemp(DoTrinary(t,dictionary.GetValue(stx.Pop),
          dictionary.GetValue(stx.Pop),dictionary.GetValue(stx.Pop))));

        assignOp  :
        BEGIN
          t := stx.Pop;
          RPNresult := dictionary.GetValue(t);   { for possible Eval call}
          dictionary.SetValue(stx.Pop,dictionary.GetValue(t));
          dictionary.RemoveTemps;
        END {BEGIN};
      END {CASE};
    UNTIL dictionary.Kind(t) = EndExpression;

    IF stx.size = 1 THEN
      RPNresult := dictionary.GetValue(stx.Pop);

    ExecutePostFix := TRUE;
{}END {ExecutePostfix};




{}FUNCTION EvaluatePostfix(VAR x:REAL):BOOLEAN;
{+H
---------------------------------------------------------------------------
  Purpose     - Interpret a RPN expression when the result is not assigned
                to a variable.

  Declaration - function EvaluatePostfix(VAR x:REAL):BOOLEAN;
---------------------------------------------------------------------------}
  BEGIN
    IF ExecutePostfix THEN BEGIN
      x := RPNresult;
      EvaluatePostfix := TRUE;
    END ELSE BEGIN
      x := 0;
      EvaluatePostfix := FALSE;
    END {BEGIN};
{}END {EvaluatePostfix};




BEGIN
END {BEGIN}.